home *** CD-ROM | disk | FTP | other *** search
/ HyperLib 1997 Winter - Disc 1 / HYPERLIB-1997-Winter-CD1.ISO.7z / HYPERLIB-1997-Winter-CD1.ISO / オンラインウェア / UTIL / Alpha 6.5.sit / Tcl / SystemCode / procs.tcl < prev    next >
Text File  |  1996-08-15  |  31KB  |  1,235 lines
  1.  
  2. #==============================================================================
  3. # Load electric alias, rebind tcl file completion for precedence.
  4. proc loadElectricAlias {} {
  5.     global HOME
  6.     uplevel #0 {
  7.         source "$HOME:Tcl:ElectricAlias:electricAlias.tcl"
  8.     }
  9.     message "ElectricAlias loaded."
  10.     bind '¥t' tclFileCompletion "Shel"
  11.     enableMenuItem -m install "Electric Alias" off
  12. }
  13.  
  14. proc debug {} {
  15.     uplevel #0 {
  16.         set debugging 1
  17.     }
  18. }
  19.  
  20.  
  21. proc normalLeftBracket {} {
  22.     insertText "¥{"
  23. }
  24. proc normalRightBracket {} {
  25.     insertText "¥}"
  26. }
  27. bind '¥[' <zs>  normalLeftBracket
  28. bind '¥]' <zs>  normalRightBracket
  29.             
  30. # Select the next or current word. If word already selected, will go to next.
  31. proc hiliteWord {} {
  32.     if {[getPos]!=[selEnd]}    forwardChar
  33.     forwardWord
  34.     set start [getPos]
  35.     backwardWord
  36.     select $start [getPos]
  37. }
  38. bind 'h' <z> hiliteWord
  39.  
  40. #================================================================================
  41. # Mode variables
  42. #================================================================================
  43. # For mark stack.
  44. set markName 0
  45. set markStack ""
  46.  
  47. # mapping of windows to current modes.
  48. set winModes("") ""
  49.  
  50. # making vars local to windows
  51. # 'incomingVars' used to hold old var values that have been overwritten in current window
  52.  
  53. #================================================================================
  54. # Handle 'flag' and 'var' menu selections.
  55. #================================================================================
  56. # proc editFlag {menu item} {
  57. #     global $item incomingVars localVars modifiedVars tcl_var_procs
  58. # 
  59. #     if {[regexp {¥? (.*)} $item dummy var]} {
  60. #         alphaHelp
  61. #         eval select [search -f 1 -r 1 "^$var"]
  62. #         return
  63. #     }
  64. #     lappend modifiedVars $item
  65. #     set val [expr ([set $item]-1)*-1]
  66. #     markMenuItem $menu $item [expr ($val)?"on":"off"]
  67. #     set $item $val
  68. # 
  69. #     if {[info exists tcl_var_procs($item)]} {
  70. #         $tcl_var_procs($item) $item
  71. #     }
  72. # }
  73.  
  74. proc editVar {menu item} {
  75.     global $item incomingVars localVars modifiedVars
  76.  
  77.     if {[regexp {¥? (.*)} $item dummy var]} {
  78.         alphaHelp
  79.         eval select [search -f 1 -r 1 "^$var"]
  80.         return
  81.     }
  82.     lappend modifiedVars $item
  83.     append prmpt "New Value of " $item ": "
  84.     if ![catch {prompt $prmpt [set $item]} res] {
  85.         set $item $res
  86.     }
  87. }
  88.  
  89.  
  90.  
  91.  
  92. #================================================================================
  93.  
  94. # Instantiate a global variable to the path of a file (usually an app). As a
  95. # side-effect, make the instantiation permanent.
  96. proc addAppPath {name var} {
  97.     global $var modifiedVars
  98.     
  99.     if {$name == "CodeWarrior Compiler"} {
  100.         alertnote {Please locate the compiler via menu item "Config:App Paths:CodeWarrior Compiler"}
  101.         error ""
  102.     } elseif {$name == "CodeWarrior Debugger"} {
  103.         alertnote {Please locate the debugger via menu item "Config:App Paths:CodeWarrior Debugger"}
  104.         error ""
  105.     }
  106.         
  107.     set $var [getfile "Find '$name' app:"]
  108.     lappend modifiedVars $var
  109. }
  110.  
  111.  
  112. proc getFileSig {f} {
  113.     getFileInfo $f arr
  114.     return $arr(creator)
  115. }
  116.  
  117. proc getFileType {f} {
  118.     getFileInfo $f arr
  119.     return $arr(type)
  120. }
  121.  
  122.  
  123. # Look for given app sig in active processes. If not there, try to 
  124. # launch with 'path' prompting for 'path' if necessary.
  125. # Return the real name of the app. Don't switch.
  126.  
  127. # Slightly modified version of 'checkRunning' that looks for any of a
  128. # list of running apps.  The name of the app is returned. 
  129. # 
  130. proc checkRunning {prompt sigs path {in_front 1}} {
  131.     global $path
  132.  
  133.     # See if a process w/ any of the acceptable sigs already running.
  134.     # If so, use it, whether it's the one specified by $path or not.
  135.     #
  136.     foreach proc [processes] {
  137.         # if a running app has the correct sig, ...
  138.         if {[lsearch -exact $sigs [lindex $proc 1]] >= 0} {
  139.             # ...then return its name.
  140.             return [lindex $proc 0]
  141.         }
  142.     }
  143.  
  144.     # If the path variable or the file it references don't exist,
  145.     # or if its sig isn't one that we expect, then prompt the user 
  146.     # to locate the app.
  147.     #
  148.     if {![info exists $path] || ![file exists [set $path]] 
  149.              || [lsearch -exact $sigs [getFileSig [set $path]]] < 0} {
  150.         if {[catch {addAppPath $prompt $path}]} return
  151.     }
  152.  
  153.     # Check that the user's choice has an acceptable sig
  154.     if {[lsearch -exact $sigs [getFileSig [set $path]]] < 0} {
  155.         unset $path
  156.         message "Inappropriate file chosen"
  157.         return {} 
  158.     }
  159.     
  160.     # Launch the app
  161.     if {$in_front} {
  162.         if {[catch {launch -f [set $path]}]} {
  163.             error "Problem with launching file (out of memory?)"
  164.         }
  165.     } else {
  166.         if {[catch {launch [set $path]}]} {
  167.             error "Problem with launching file (out of memory?)"
  168.         }
  169.     }        
  170.     
  171.     # Return the name of the chosen application
  172.     return [file tail [set $path]]
  173. }
  174.  
  175.  
  176. #===============================================================================
  177.  
  178. # Switch to 'sig', launching if necesary
  179. proc launchForeAppl {sig} {
  180.     set name [nameFromAppl $sig]
  181.     if {[catch {switchTo "'$sig'"}]} {
  182.         launch -f $name
  183.     }        
  184.     return $name
  185. }
  186.  
  187. # Ensure that the app is at least running in the background.
  188. proc launchBackAppl {sig} {
  189.     set name [nameFromAppl $sig]
  190.     launch $name
  191.     return $name
  192. }
  193.  
  194. # Check to see if any of the 'sigs' is running. If so, return its name.
  195. # Otherwise, attempt to launch the file named by 'sig'.
  196. proc launchBackApplSigs    {sigs sig {prompt "Please locate the application:"}} {
  197.     global $sig    modifiedVars
  198.     foreach    p [processes] {
  199.         if { [set ind [lsearch -exact $sigs [lindex $p 1]]] >= 0 } {
  200.             set s [lindex $sigs $ind]
  201.             if { ![info exists $sig] || ($s != [set    $sig]) } {
  202.                 set    $sig $s
  203.                 lappend    modifiedVars $sig
  204.             }
  205.             return [nameFromAppl $s]
  206.         }
  207.     }
  208.     if {![info exists $sig] || ([set $sig] == "")}    {
  209.         set    $sig [getFileSig [getfile $prompt]]
  210.         lappend    modifiedVars $sig
  211.     }
  212.     return [launchBackAppl [set    $sig]]
  213. }
  214.  
  215. proc getApplSig {prompt sig} {
  216.     global $sig modifiedVars
  217.     if {[catch {nameFromAppl [set $sig]}]} {
  218.         set $sig [getFileSig [getfile $prompt]]
  219.         lappend modifiedVars $sig
  220.     }
  221. }
  222.  
  223. #================================================================================
  224. # Excalibur is the only Mac spell-checker that I know of which will handle LaTeX as
  225. # well as ordinary text.
  226.  
  227.  
  228. proc spellcheckWindow {} {
  229.     global resumeRevert
  230.  
  231.     set name [launchForeAppl XCLB]
  232.  
  233.     if {[winDirty]} {
  234.         if {[askyesno "Save '[lindex [winNames] 0]'?"] == "yes"} {
  235.             save
  236.         }
  237.     }
  238.     sendOpenEvent noReply [file tail $name] [car [winNames -f]]
  239.     set resumeRevert 1
  240. }
  241.  
  242. proc spellcheckSelection {} {
  243.     global excaliburPath 
  244.  
  245.     catch {checkRunning Excalibur XCLB excaliburPath} name
  246.  
  247.     if {[getPos] == [selEnd]} {
  248.         beep
  249.         message "No selection"
  250.         return;
  251.     }
  252.     copy
  253.     switchTo $name
  254. }
  255.  
  256. #================================================================================
  257.  
  258.  
  259. proc alphaHelp {} {
  260.     global HOME alphaLite
  261.     if $alphaLite {
  262.         edit -r "$HOME:Help:Quick Start"
  263.     } else {
  264.         edit -r "$HOME:Help:Manual"
  265.     }
  266. }
  267.  
  268.  
  269. proc tclHelp {} {
  270.     global HOME
  271.     edit -r "$HOME:Help:Tcl Commands"
  272. }
  273.  
  274.  
  275. proc dividingLine {} {
  276.     insertText "===============================================================================¥r"
  277. }
  278. bind 'l' <C> dividingLine
  279.  
  280. proc texDividingLine {} {
  281.     insertText "%===============================================================================¥r"
  282. }
  283. bind 'l' <C> texDividingLine TeX
  284.  
  285. proc cDividingLine {} {
  286.     insertText "//===============================================================================¥r"
  287. }
  288. bind 'l' <C> cDividingLine C
  289. bind 'l' <C> cDividingLine C++
  290.  
  291. proc tclDividingLine {} {
  292.     insertText "#===============================================================================¥r"
  293. }
  294. bind 'l' <C> tclDividingLine Tcl
  295.  
  296.  
  297. #================================================================================
  298.  
  299. if {![string length [info commands oldCd]]} {
  300.     rename cd oldCd
  301. }
  302.  
  303. proc cd args {
  304.     global HOME
  305.     if {[llength $args]} {
  306.         oldCd [string trim [eval list $args] "        ¥{¥}"]
  307.     } else {
  308.         oldCd $HOME
  309.     }
  310. }
  311.  
  312.  
  313.  
  314. #############################################################################
  315. #  List the name and value of each element of the array $arrName.
  316. #  (Convenient to use as a shell command.)
  317. #
  318. #  Note: it's slower to insert the lines one-by-one like this, but 
  319. #  assembling everything in $lines before inserting can seriously crash Alpha
  320. #  if the result is too big.  (Trying to list the contents of $auto_index()
  321. #  will do it.)  This method seems to be more robust.
  322. #
  323. proc listArray {arrName} {
  324.     global $arrName
  325.     set lines {}
  326.     if {![catch {info vars $arrName}]} {
  327.         foreach nm [lsort -ignore [array names $arrName]] {
  328.             append lines [format "¥r%-20s ¥"%s¥"" $nm [set ${arrName}($nm)]]
  329.         }
  330.         insertText $lines
  331.     } else {
  332.         alertnote "¥"$arrName¥" doesn't exist in this context"
  333.     }
  334. }
  335.  
  336.  
  337.  
  338. #================================================================================
  339.     
  340. proc selectParagraph {} {
  341.     set pos [getPos]
  342.     set start [paraStart $pos] 
  343.     set finish [paraFinish $pos]
  344.     goto $start
  345.     select $start $finish
  346. }
  347.  
  348. # wrapText ==  getText ; breakIntoLines ; replaceText
  349. # Remove text from window, transform (join, del-ws), insert back into window.
  350. proc fillTextByPar {from to} {
  351.     set text [getText $from $to]
  352.     regsub -all "¥r(¥[ ¥t¥]*¥r)+" $text "¥r¥r¥r" text
  353.     regsub -all "(¥[^¥r¥])¥r" $text "¥¥1 " text
  354.     regsub -all "¥[ ¥t¥]+" $text " " text
  355.     return [breakIntoLines $text]
  356. }
  357.  
  358. proc fillRegionByPar {{start -1} {finish -1}} {
  359. #    # if {[getPos] == [selEnd]} { return}
  360.     if {($start < 0) || ($finish < 0)} {
  361.         set start [lineStart [getPos]]
  362.         set finish [selEnd] }
  363.     if {$start >= $finish} return
  364.     goto $start
  365.     set text [fillTextByPar $start $finish]
  366.     replaceText $start $finish $text "¥r"
  367. }
  368.     
  369. #
  370. # join Lines in region -- if no optional args, use selection
  371. #
  372. proc joinRegion {{from -1} {to -1}} {
  373.     if {($from < 0) || ($to < 0)} {    set from [getPos] ; set to [selEnd] }
  374.     if {$from >= $to} return
  375.     set text [getText $from $to]
  376.     regsub -all "¥r(¥[ ¥t¥]*¥r)+" $text "¥r¥r¥r" text
  377.     regsub -all "(¥[^¥r¥])¥r" $text "¥¥1 " text
  378.     replaceText $from $to $text "¥r"
  379. }
  380. # WARNING:    regsub ^$ refers to string endpts (not lines)
  381. # FUTURE:    filterLines like perl:
  382. #    replaceText[apply_to_all(cmd,split [getText [getPos] [selEnd]] "¥r")]
  383. # OR:    replaceInRegion: dup_¥r, $=>¥r ??
  384. #
  385.  
  386.  
  387. #
  388. # Remove text from window, transform (delete dup ws), insert back into window.
  389. #
  390. # inputs: message, alertnote, askyesno, listpick, prompt KILLS SELECTION.
  391. # search: bnds = search -forward -regExpr -ignoreCase -matchWords -noabort 
  392. #        -l limit pat pos
  393. # 
  394. proc regsubInRegion {from to srch repl} {
  395.     if {![string length $srch]} return
  396.     if {$from >= $to} return
  397.     set text [getText $from $to]
  398.     regsub -all "$srch" $text "$repl" text
  399.     replaceText $from $to $text
  400. }
  401. #    while {($pos < $to) &&
  402. #          ![catch {search -s -f 1 -r 1 -i 1 -m 0 "$srch" $pos} mtch]} {
  403. #        set mbeg [lindex $mtch 0]
  404. #        set pos [lindex $mtch 1]
  405. #        replaceText $mbeg $pos $repl }
  406.  
  407. #proc backSlashSub {arg} { eval [concat return "¥"$arg¥""] }
  408.  
  409. proc backSlashSub {arg} {
  410.     regsub -all {¥¥} $arg {¥¥¥¥} arg
  411.     regsub -all {¥[} $arg {¥¥[} arg
  412.     regsub -all {¥]} $arg {¥¥]} arg
  413.     eval [concat return "¥"$arg¥""]
  414. }
  415.  
  416. proc replaceInRegion {} {
  417.     if [catch {prompt "Search RegExpr:" ""} srch] return
  418.     if [catch {prompt "Replace String:" ""} repl] return
  419.     if {![string length $srch]} return
  420.     regsubInRegion [getPos] [selEnd] ¥
  421.         [backSlashSub "$srch"] [backSlashSub "$repl"]
  422. }
  423.  
  424. #
  425. # Apply command to each line (or paragraph) in selection ;
  426. #    if no cmd arg then prompts for it
  427. #
  428. proc filterLines {{cmd 0} {parunit 0}} {
  429.     if {$cmd == 0} {
  430.       if {[catch { prompt "Line-filter command: " "" } cmd]} { return } }
  431.     if {![string length $cmd]} return
  432.     set unitStart lineStart
  433.     set unitEnd nextLineStart
  434.     if {$parunit} {
  435.         set unitStart paraStart
  436.         set unitEnd paraFinish }
  437.     set pos [$unitStart [getPos]]
  438.     set finish [selEnd]
  439.     if {$pos >= $finish} return
  440.     goto $pos
  441.     createTMark "filterLend" $finish
  442.     set next [$unitEnd $pos]
  443.     while {(($next > $pos) && ($pos < $finish))} {
  444.         goto [expr $next-1]
  445.         createTMark "filterLnext" $next
  446.         setMark
  447.         goto $pos
  448.         markHilite
  449.         if {[catch [list uplevel #0 "$cmd"] retval]} {
  450.             select $pos $finish
  451.             alertnote $retval
  452.             return
  453.         }
  454.         if {$next==$finish} break
  455.         set ind [lsearch -regexp [lindex [getTMarks] 0] "filterLend.*"]
  456.         set finish [lindex [lindex [lindex [getTMarks] 0] $ind] 2]
  457.         gotoTMark "filterLnext"
  458.         set pos [$unitStart [getPos]]
  459.         set next [$unitEnd $pos]
  460.     }
  461.     removeTMark "filterLend"
  462.     removeTMark "filterLnext"
  463. }
  464.  
  465.  
  466. proc filterParagraphs {{cmd 0}} { filterLines $cmd 1 }
  467.  
  468. # WARNING: deselecting sets the mark to selEnd
  469. proc sortParagraphs {{from -1} {to -1}} {
  470.     if {($from < 0) || ($to < 0)} {    set from [getPos] ; set to [selEnd] }
  471.     if {$from >= $to} return
  472.     joinRegion {$from $to}
  473.     select [getPos] [nextLineStart [getMark]]
  474.     sortLines
  475.     select [getPos] [getPos]
  476.     regsubInRegion [getPos] [getMark] "¥r" "¥r¥r" 
  477.     wrapRegion
  478. }
  479.  
  480. #
  481. # Sample
  482. #
  483. proc filterRegion {{from -1} {to -1} {cmd 0} {newwin 0}} {
  484.     if {$cmd == 0} {
  485.       if {[catch { prompt "Eval command: " "" } cmd]} { return }
  486.     }
  487.     if {![string length $cmd]} return
  488.     if {($from < 0) || ($to < 0)} {    set from [getPos] ; set to [selEnd] }
  489.     if {$from >= $to} return
  490.     set pos [getPos]
  491.     set text [getText $from $to]
  492.     set text [$cmd $text]
  493.     replaceText $from $to $text "¥r"
  494.     goto $pos
  495. }
  496.  
  497.  
  498. #
  499. set lastEvaled ""
  500. proc evaluate {} {
  501.     global lastEvaled
  502.     if {[string length $lastEvaled]} {
  503.         set p "M-x ($lastEvaled): "
  504.     } else {
  505.         set p "M-x: "
  506.     }
  507.     if {[catch {statusPrompt $p} text]} {return}
  508.     if {![string length $text]} {set text $lastEvaled}
  509.     $text
  510.     set lastEvaled $text
  511. }
  512.  
  513.  
  514. # First, define macros to bypass the electric braces.
  515. proc ordLeftBrace {} {
  516.     insertText "        ¥{"
  517. }
  518. bind {'['} <cs> ordLeftBrace
  519.  
  520. proc ordRightBrace {} {
  521.     insertText "¥}"
  522.     blink [matchIt "¥}" [expr [getPos]-1]]
  523. }
  524. bind {']'} <cs> ordRightBrace
  525.     
  526. proc quoteWord {} {
  527.     backwardWord
  528.     insertText "'"
  529.     forwardWord
  530.     insertText "'"
  531. }
  532. bind ''' <z> quoteWord
  533.  
  534. #================================================================================
  535.  
  536. proc tomac {fname} {
  537.     set fd [open $fname "r"]
  538.     set text [read $fd]
  539.     close $fd
  540.     set fd [open $fname "w"]
  541.     regsub "¥n" $text "¥r" text
  542.     puts -nonewline $fd $text
  543.     close $fd
  544. }
  545.  
  546. proc tounix {fname} {
  547.     set fd [open $fname "r"]
  548.     set text [read $fd]
  549.     close $fd
  550.     set fd [open $fname "w"]
  551.     regsub "¥r" $text "¥n" text
  552.     puts -nonewline $fd $text
  553.     close $fd
  554. }
  555.  
  556.  
  557. proc cat args {
  558.     set files ""
  559.     foreach a $args {
  560.         foreach f [glob $a] {
  561.             lappend files $f
  562.         }
  563.     }
  564.     foreach f $files {
  565.         append text "==============<$f>==============¥r"
  566.         set fd [open $f "r"]
  567.         append text "[read $fd]¥r¥r"
  568.         close $fd
  569.     }
  570.     return $text
  571. }
  572.  
  573. proc catto args {
  574.     set len [llength $args]
  575.     set to [lindex $args [expr $len -1]]
  576.     set args [lrange $args 0 [expr $len -2]]
  577.  
  578.     set files ""
  579.     foreach a $args {
  580.         foreach f [glob $a] {
  581.             lappend files $f
  582.         }
  583.     }
  584.     foreach f $files {
  585.         append text "==============<$f>==============¥r"
  586.         set fd [open $f "r"]
  587.         append text "[read $fd]¥r¥r"
  588.         close $fd
  589.     }
  590.  
  591.     set dfile $to
  592.     if {[file exists $dfile]} {
  593.         set fid [open $dfile "a"]
  594.     } else {
  595.         set fid [open $dfile "w"]
  596.     }
  597.     puts $fid $text
  598.     close $fid
  599. }
  600.  
  601.  
  602. ##############################################################################
  603. #  To be used in the windows created by "matchingLines" or by batch searches.
  604. #
  605. #  With the cursor positioned in a line corrsponding to a match, 
  606. #  go back and select the line in the original file that 
  607. #  generated this match.  (Like emacs 'Occur' functionality)
  608. #
  609. proc gotoMatch {} {
  610.     if {[string match "*MAILBOX*" [lindex [winNames] 0]]} {
  611.         mailGotoMatch
  612.         return
  613.     }
  614.     global tileHeight tileWidth tileTop tileLeft tileHeight errorHeight errorDisp tileMargin
  615.     set errorDisp [expr (2 * ($tileHeight - $tileMargin)) / 3]
  616.     set text [getText [lineStart [getPos]] [expr [nextLineStart [getPos]] - 1]]
  617.     set ind1 [string first "ｰ" $text]
  618.     set ind2 [string last "ｰ" $text]
  619.     if {$ind1 == $ind2} {
  620.         set fname [string trim [string range $text $ind1 end] {ｰ}]
  621.         set msg ""
  622.     } else {
  623.         set fname [string trim [string range $text $ind1 $ind2] {ｰ}]
  624.         set msg [string trim [string range $text $ind2 end] {ｰ}]
  625.     }
  626.     
  627.     set top $tileTop
  628.     set geo [getGeometry]
  629.     if {([lindex $geo 0] != $tileLeft) || ([lindex $geo 1] != $top) || ([lindex $geo 3] != $errorHeight) } {
  630.         moveWin $tileLeft $top
  631.         sizeWin $tileWidth $errorHeight
  632.     }
  633.     set mar $tileMargin
  634.     incr top [expr $errorHeight + $mar]
  635.     if {[expr {[lsearch [winNames -f] "*$fname"] >= 0}]} {
  636.         if {[string match ":*" $fname]} {
  637.             set fname [file tail $fname]
  638.         }
  639.         bringToFront $fname
  640.         set geo [getGeometry]
  641.         if {([lindex $geo 0] != $tileLeft) || ([lindex $geo 1] != $top) || ([lindex $geo 2] != $tileWidth) || ([lindex $geo 3] != $errorDisp) } {
  642.             sizeWin $tileWidth $errorDisp
  643.             moveWin $tileLeft $top
  644.         }
  645.     } elseif {[file exists $fname]} {
  646.         edit -g $tileLeft $top $tileWidth $errorDisp $fname
  647.     } else {
  648.         if {![string match "*Link*" [getText 0 [nextLineStart 0]]]} {
  649.             alertnote "File ¥" $fname ¥" not found." 
  650.         }
  651.         return
  652.     }
  653.     if {[regexp {Line ([0-9]+):} $text dummy line]} {
  654.         set pos [rowColToPos $line 0]
  655.         select $pos [nextLineStart $pos]
  656.     }
  657.     message $msg
  658. }
  659. bind 'c' <Cz>        gotoMatch
  660.  
  661.  
  662. #================================================================================
  663.  
  664. proc prevIntro {} {
  665.     set res [search -s -f 0 -r 0 {== } [getPos]]
  666.     display [lineStart [expr [lineStart [lindex $res 0]] - 1]]
  667. }
  668.  
  669. proc nextIntro {} {
  670.     set res [search -s -f 1 -r 0 {== } [getPos]]
  671.     set res [lindex $res 1]
  672.     set res [search -s -f 1 -r 0 {== } $res]
  673.     display [lineStart [expr [lineStart [lindex $res 0]] - 1]]
  674. }
  675.  
  676. #================================================================================
  677.  
  678. proc searchStart {} {
  679.     global search_start
  680.     select [getPos]
  681.     setMark
  682.     if {[catch {goto $search_start}]} {message "No previous search"}
  683. }
  684.  
  685. #================================================================================
  686.  
  687.  
  688. proc listBindings {} {
  689.     new -n {* Key Bindings *}
  690.     insertText [bindingList]
  691.  
  692.     goto 0
  693.     setWinInfo dirty 0
  694.     setWinInfo read-only 1
  695. }
  696.  
  697.  
  698. proc listFunctions {} {
  699.     global winModes
  700.     new -n {* Functions *}
  701.     insertText "===¥r¥tCommand-double-click on a function to see its definition¥r===¥r¥r" [join [lsort -ignore [info commands]] "¥r"] "¥r"
  702.     goto 0
  703.     setWinInfo dirty 0
  704.     changeMode [set winModes([lindex [winNames] 0]) Tcl]
  705. }
  706.  
  707.  
  708. #================================================================================
  709.  
  710. proc printArray {arr} {
  711.     global $arr
  712.         foreach n [array names $arr] {
  713.         append text "$n '[set ${arr}($n)]'¥r"
  714.     }
  715.     return [string trim $text "¥r"]
  716. }
  717.  
  718. #================================================================================
  719.  
  720. #================================================================================
  721.  
  722. proc sPrompt {msg def} {
  723.     global useStatusBar
  724.     if {!$useStatusBar} {return [prompt $msg $def]}
  725.     if {[catch {statusPrompt "$msg ($def): "} ans]} {
  726.         error "cancel"
  727.     }
  728.     if {![string length $ans]} {return $def}
  729.     return $ans
  730. }
  731.  
  732.  
  733. proc choicesProc {curr c} {
  734.     global choiceList
  735.     if {$c != "¥t"} {return $c}
  736.     
  737.     set matches {}
  738.     foreach w $choiceList {
  739.         if {[string match "$curr*" $w]} {
  740.             lappend matches $w
  741.         }
  742.     }
  743.     if {![llength $matches]} {
  744.         beep
  745.     } else {
  746.         return [string range [largestPrefix $matches] [string length $curr] end]
  747.     }
  748.     return ""
  749. }
  750.  
  751.  
  752. proc sPromptChoices {msg def choiceListIn} {
  753.     global useStatusBar choiceList
  754.     set choiceList $choiceListIn
  755.     if {[catch {statusPrompt -f "$msg ($def): " choicesProc} ans]} {
  756.         error "cancel"
  757.     }
  758.     if {![string length $ans]} {return $def}
  759.     return $ans
  760. }
  761.  
  762. #================================================================================
  763. proc quoteChar {} {
  764.     message "Literal keystroke to be inserted:"
  765.     insertText [getChar]
  766. }
  767. #===============================================================================
  768.  
  769. proc saveACopyAs {} {
  770.     if {[file exists [set nm [car [winNames -f]]]]} {
  771.         set nm2 [putfile "Save a copy as:" [file tail $nm]]
  772.         cp $nm $nm2
  773.     }
  774. }
  775. #===============================================================================
  776. proc removeDups {l} {
  777.     foreach f $l {
  778.         set silly($f) 1
  779.     }
  780.     if {[info exists silly]} {
  781.         return [array names silly]
  782.     }
  783. }
  784.             
  785.  
  786. #===============================================================================
  787.  
  788. proc printLeftHeader {pg} {
  789.     global printHeader printHeaderTime printHeaderFullPath
  790.     
  791.     if {!$printHeader} return ""
  792.     
  793.     if {$printHeaderFullPath} {
  794.         set text [car [winNames -f]]
  795.     } else {
  796.         set text [lindex [winNames] 0]
  797.     }
  798.     
  799.     if {$printHeaderTime} {
  800.         append text "      [join [mtime [now] short]]"
  801.     }
  802. }
  803.  
  804. proc printRightHeader {pg} {
  805.     return "Page $pg"
  806. }
  807.  
  808. #===============================================================================
  809.  
  810. proc toggleNumLock {} {
  811.     global numLock modifiedVars
  812.     
  813.     set numLock [expr -1 * ($numLock - 1)]
  814.     lappend modifiedVars numLock
  815. }
  816.  
  817. #===============================================================================
  818.  
  819. proc register {} {
  820.     global HOME
  821. #    edit -r "$HOME:Help:Registering"
  822.     launch -f "$HOME:Register"
  823. }
  824.  
  825. #===============================================================================
  826. # Useful for -command flag of 'lsort'.
  827. proc sortByTail {one two} {
  828.     string compare [file tail $one] [file tail $two]
  829. }
  830.  
  831.  
  832. #===============================================================================
  833.  
  834. proc cmdDoubleClick {{from -1} {to -1} {shift 0} {option 0} {control 0}} {
  835.     global mode alphaLite
  836.     
  837.     if {!$alphaLite && [string length [set whe [expandURL]]]} {
  838.         sendUrl [getSelect]
  839.     } else {
  840.         if {$from < 0} {
  841.             set from [getPos]
  842.             set to [selEnd]
  843.             if {$from == $to} {
  844.                 hiliteWord
  845.                 set from [getPos]
  846.                 set to [selEnd]
  847.             }
  848.         }
  849.         
  850.         if {[string length [info commands ${mode}DblClick]]} {
  851.             if {[llength [info args ${mode}DblClick]] == 2} {
  852.                 ${mode}DblClick $from $to
  853.             } else {
  854.                 ${mode}DblClick $from $to $shift $option $control
  855.             }
  856.         } else {
  857.             message "No docs"
  858.         }
  859.     }    
  860. }
  861.  
  862. #===============================================================================
  863.  
  864.  
  865. proc editMark {fname mname args} {
  866.     if {[set pos [lsearch [winNames -f] "*$fname*"]] >= 0}  {
  867.         bringToFront [lindex [winNames -f] $pos]
  868.     } else {
  869.         if {[lsearch $args {-r}] >= 0} {
  870.             edit -r "$fname"
  871.         } else {
  872.             edit "$fname"
  873.         }
  874.     }
  875.     if {[lsearch [getNamedMarks -n] $mname] < 0} {
  876.         global    mode
  877.         ${mode}MarkFile
  878.     } 
  879.     gotoMark $mname
  880. }
  881.  
  882.  
  883. proc winDirty {} {
  884.     getWinInfo arr
  885.     return $arr(dirty)
  886. }
  887.  
  888.  
  889. #===============================================================================
  890.  
  891. proc lreverse {l} {
  892.     if {[llength $l] > 1} {
  893.         set first [lindex $l 0]
  894.         set l [lreverse [lrange $l 1 end]]
  895.         lappend l $first
  896.     }
  897.     return $l
  898. }
  899.  
  900.     
  901. #===============================================================================
  902.  
  903.  
  904. set {patternLibrary(Pascal to C Comments)}      { {¥{([^¥}]*)¥}}    {/* ¥1 */}     }
  905. set {patternLibrary(C++ to C Comments)}            { {//(.*)}            {/* ¥1 */}     }
  906. set {patternLibrary(Space Runs to Tabs)}        { { +}                {¥t}         }
  907.  
  908.  
  909.  
  910. proc getPatternLibrary {} {
  911.     global patternLibrary
  912.     
  913.     foreach nm [array names patternLibrary] {
  914.         lappend nms [concat [list $nm] $patternLibrary($nm)]
  915.     }
  916.     return $nms
  917. }
  918.  
  919. proc rememberPatternHook {search replace} {
  920.     global patternLibrary
  921.     if {[catch {set name [prompt "New pattern's name?" ""]}]} {
  922.         return ""
  923.     }
  924.     addArrDef patternLibrary $name [list $search $replace]
  925.     set patternLibrary($name) [list $search $replace]
  926.     return $name
  927. }
  928.  
  929. proc deletePatternHook {} {
  930.     global patternLibrary
  931.     
  932.     
  933.     set temp [list prompt "Delete which pattern?" [lindex [array names patternLibrary] 0] "Pats:"]
  934.     set name [eval [concat $temp [array names patternLibrary]]]
  935.     removeArrDef patternLibrary $name
  936.     unset patternLibrary($name)
  937. }
  938.  
  939. #===============================================================================
  940. # Support for Peter Gontier's 'ClickWarrior' (Doesn't work for 68k).
  941. #===============================================================================
  942.  
  943. eventHandler ALFA CWOF clickHandler
  944.  
  945. proc clickHandler {msg} {
  946.     global HOME ALPHA CODEWarrior CWCLASS
  947.     switchTo $ALPHA
  948.     checkCw
  949.     if {[regexp {ﾒ(.*)ﾓ.*ﾇ.*ﾈ.*ﾇ(.*)ﾈ.*ﾇ(.*)ﾈ} $msg dummy fname find sind]} {
  950.         set res [AEBuild -t 500000 -r $CODEWarrior $CWCLASS GFil "----" "long(ﾇ0000$findﾈ)" Segm "long($sind)"]
  951.         if {[regexp {FTxt} $res]} {
  952.             regexp {ﾇ(.*)ﾈ} $res dummy spec
  953.             set f [specToPathName $spec]
  954.             edit $f
  955.         }
  956.     }
  957. }
  958.  
  959. #===============================================================================
  960. proc quickFind {} {isearch}
  961. proc reverseQuickFind {} {rsearch}
  962.  
  963. proc pushPosition {} {pushMark}
  964. proc popPosition {} {popMark}
  965. #===============================================================================
  966. proc literalChar {} {
  967.     return [expr {[lookAt [expr [getPos] - 1]] == "¥¥"}]
  968. }
  969. proc isSelection {} {
  970.     return [string length [getSelect]]
  971. }
  972.  
  973. proc findPatJustBefore { findpat pat {pos ""} {matchw ""} } {
  974.     if { $pos == "" } {set pos [getPos] }
  975.     if { $matchw != "" } { upvar  $matchw word }
  976.     if { ![catch {search -s -f 0 -r 1 "$findpat" $pos} res] } {
  977.         if { [regexp "$pat" [getText [lindex $res 0] $pos] dum word] } {
  978.             return [lindex $res 0]
  979.         }
  980.     }
  981.     return
  982. }
  983.  
  984. #===============================================================================
  985. proc mkdir {dir} {
  986.     oldMkdir [list $dir]
  987. }
  988.  
  989. proc rmdir {dir} {
  990.     oldRmdir [list $dir]
  991. }
  992.  
  993. #===============================================================================
  994. proc textToAlpha {{dir ""}} {
  995.     set num 0
  996.     if {![string length $dir]} {
  997.         set dir [get_directory -p "Creators to 'ALFA':"]
  998.     }
  999.  
  1000.     if {![catch {glob "$dir:*"} files]} {
  1001.         foreach f $files {
  1002.             if {[file isfile $f] && ([getFileType $f] == "TEXT") && ([getFileSig $f] != "ALFA")} {
  1003.                 message $f
  1004.                 setFileInfo $f creator ALFA
  1005.                 incr num
  1006.             } elseif {[file isdir $f]} {
  1007.                 incr num [textToAlpha $f]
  1008.             }
  1009.         }
  1010.     }
  1011.     message "Converted $num files"
  1012.     return $num
  1013. }
  1014.  
  1015.  
  1016. #===============================================================================
  1017.  
  1018. proc briefThing {} {
  1019.     global lastBrief
  1020.     getWinInfo arr
  1021.     set curr $arr(currline)
  1022.     set where [posToRowCol [getPos]]
  1023.     set row [car $where]
  1024.     set col [cadr $where]
  1025.     
  1026.     if {$col} {
  1027.         set lastBrief [getPos]
  1028.         goto [lineStart [getPos]]
  1029.     } elseif {$curr != $row} {
  1030.         goto [rowColToPos $curr 0]
  1031.     } elseif {[getPos]} {
  1032.         goto 0
  1033.     } else {
  1034.         goto $lastBrief
  1035.     }
  1036. }
  1037.  
  1038. ########################################
  1039. #                                       #
  1040. #    A few random lisp'ish functions.   #
  1041. #                                       #
  1042. ########################################
  1043.  
  1044. proc car {l} {lindex $l 0}
  1045. proc cadr {l} {lindex $l 1}
  1046. proc caddr {l} {lindex $l 2}
  1047. proc cadddr {l} {lindex $l 3}
  1048. proc caddddr {l} {lindex $l 4}
  1049. proc cdr {l} {lrange $l 1 end}
  1050. proc cddr {l} {lrange $l 2 end}
  1051. proc cons {e l} {concat [list $e] $l}
  1052. proc mapcar args {return [eval map $args]}
  1053.  
  1054. proc map {func l} {
  1055.     set out {}
  1056.     foreach el $l {
  1057.         lappend out [eval $func [list $el]]
  1058.     }
  1059.     return $out
  1060. }
  1061.  
  1062.  
  1063. #===============================================================================
  1064.  
  1065. proc deconstruct {} {
  1066.     global HOME 
  1067.     
  1068.     set files {}
  1069.     if {![catch {glob "$HOME:Tcl:Modes:*Mode.tcl"} modes]} {
  1070.         set files $modes
  1071.     }
  1072.     if {![catch {glob "$HOME:Tcl:Menus:*Menu.tcl"} menus]} {
  1073.         set files [concat $files $menus]
  1074.     }
  1075.     
  1076.     foreach f $files {
  1077.         regexp {.*:(.*)M.*.tcl} $f dummy it
  1078.         set theFiles($it) $f
  1079.         lappend tails $it
  1080.     }
  1081.  
  1082.     set res [listpick -p "Permanently remove which modes and menus?" -l [lsort -ignore $tails]]
  1083.     
  1084.     if {[llength $res] && ([askyesno "Are you absolutely sure?"] == "yes")} {
  1085.         foreach tag $res {
  1086.             set name $theFiles($tag)
  1087.             regexp {(.*)M.*.tcl} $name dummy prefix
  1088.             foreach f [glob "${prefix}*.tcl"] {
  1089.                 lappend rfiles $f
  1090.             }
  1091.  
  1092.             set tag [file tail $tag]
  1093.             if {$tag == "perl"} {
  1094.                 catch {rm $HOME:Help:*Perl*}
  1095.             } elseif {$tag == "latex"} {
  1096.                 catch {rm $HOME:Help:LaTeX*}
  1097.             } elseif {$tag == "bibtex"} {
  1098.                 catch {rm $HOME:Help:Bib*}
  1099.             } elseif {$tag == "html"} {
  1100.                 catch {rm $HOME:Help:HTML*}
  1101.             }
  1102.         }
  1103.  
  1104.         foreach f $rfiles {
  1105.             catch {rm $f}
  1106.         }
  1107.  
  1108.         foreach dir [list "$HOME:Tools" "$HOME:Tcl:ElectricAlias" "$HOME:Tcl:UserCode" "$HOME:Help"] {
  1109.             if {[file exists $dir] && ([askyesno "Remove '$dir'?"] == "yes")} {
  1110.                 if {[catch {recursiveRm $dir}]} {
  1111.                     alertnote "Problem removing '$dir'."
  1112.                 }
  1113.             }
  1114.         }
  1115.         
  1116.         rebuildTclIndices
  1117.  
  1118.         alertnote "You must now restart Alpha..."
  1119.         quit
  1120.     }
  1121. }
  1122.  
  1123. proc recursiveRm dir {
  1124.     if {![catch {glob $dir:*} files]} {
  1125.         foreach f $files {
  1126.             if {[file isdir $f]} {
  1127.                 recursiveRm $f
  1128.             } else {
  1129.                 rm $f
  1130.             }
  1131.         }
  1132.     }
  1133.     rmdir $dir
  1134. }
  1135.  
  1136. ###########################################################################
  1137. #  better-cp-mv.tcl  -- modification of your routines, by Mark Nagata
  1138. #  for Alpha 5.72,  1/04/94
  1139. ###########################################################################
  1140. proc cp args {
  1141.     if {[set len [llength $args]] < 2} {
  1142.         error "usage: cp <file1> <file2>¥r       cp <file1> .... <dir>"
  1143.     }
  1144.     set len [expr $len-1]
  1145.     set dir [lindex $args $len]
  1146.     if {![regexp {:} $dir] && $dir != ""} {
  1147.         set dir ":$dir"
  1148.     }
  1149.     if {[regexp {:$} $dir]} {
  1150.         set dir [string trimright $dir {:}]
  1151.     }
  1152.     set args [lreplace $args $len $len]
  1153.     set files {}
  1154.     foreach arg $args {
  1155.         append files " " [glob $arg]
  1156.     }
  1157.     set report ""
  1158.     if {[llength $files] == 1} {
  1159.         set f [lindex $files 0]
  1160.         if {[file exists $dir]} {
  1161.             set targ $dir:[file tail $f]
  1162.             append report $f¥ ->¥ $targ ¥r 
  1163.             copyFile $f $targ
  1164.         } else {
  1165.             append report $f¥ ->¥ $dir ¥r
  1166.             copyFile $f $dir
  1167.         }
  1168.     } else {
  1169.         foreach f $files {
  1170.             message [file tail $f]
  1171.             set targ $dir:[file tail $f]
  1172.             if {[catch {copyFile $f $targ} that]} {
  1173.                 append report "Error copying '$f': $that¥r"
  1174.             } else {
  1175.                 append report $f¥ ->¥ $targ ¥r
  1176.             }
  1177.         }
  1178.     }
  1179.     echo [string trimright $report]
  1180. }
  1181.  
  1182. proc mv args {
  1183.     if {[set len [llength $args]] < 2} {
  1184.         error "usage: mv <file1> <file2>¥r       mv <file1> .... <dir>"
  1185.     }
  1186.     set len [expr $len-1]
  1187.     if {![regexp {.*[^:]} [lindex $args $len] dir]} {
  1188.         set dir [string range [lindex $args $len] 1 end]
  1189.     }
  1190.     if {![regexp {:} $dir] && $dir != ""} {
  1191.         set dir [concat :$dir]}
  1192.     set args [lreplace $args $len $len]
  1193.     set files {}
  1194.     foreach arg $args {
  1195.         append files " " [glob $arg]
  1196.     }
  1197.     set report ""
  1198.     if {[llength $files] == 1} {
  1199.         set f [lindex $files 0]
  1200.         if {[file exists $dir]} {
  1201.             set targ $dir:[file tail $f]
  1202.             append report $f¥ >->¥ $targ ¥r
  1203.             moveFile $f $targ
  1204.         } else {
  1205.             append report $f¥ >->¥ $dir ¥r
  1206.             moveFile $f $dir
  1207.         }
  1208.     } else {
  1209.         foreach f $files {
  1210.             message [file tail $f]
  1211.             set targ $dir:[file tail $f]
  1212.             if {[catch {moveFile $f $targ} that]} {
  1213.                 append report "Error moving '$f': $that¥r"
  1214.             } else {
  1215.                 append report $f¥ >->¥ $targ ¥r
  1216.             }
  1217.         }
  1218.     }
  1219.     echo [string trimright $report]
  1220. }
  1221.  
  1222.  
  1223. proc rm args {
  1224.     set files {}
  1225.     foreach arg $args {
  1226.         append files " " [glob $arg]
  1227.     }
  1228.     foreach f $files {
  1229.         message [file tail $f]
  1230.         removeFile $f
  1231.     }
  1232. }
  1233.  
  1234.  
  1235.